﻿#light

// "Julien", http://cs.hubfs.net/forums/thread/7472.aspx

namespace Common.Monads

open System

type State<'state, 'a> = State of ('state ->'a * 'state)

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]     
module State =
 
  let private succeed x = State (fun s -> x, s)

  let Run (State f) s = f s

  let private bind m f =
    State (fun s ->
      let v, s = Run m s
      Run (f v) s
    )   
   
  let private delay f = State (fun s -> Run (f()) s)
 
  let private try_with m f = State (fun s -> try Run m s with e -> Run (f e) s)

  let private try_finally m f = State (fun s -> try Run m s finally f())

  let private dispose (x: #IDisposable) = x.Dispose()

  let private using r f = try_finally  (f r) (fun () -> dispose r)

  let rec private do_while p m =
    if p() then
      bind m (fun _ -> do_while p m)
    else
      succeed ()

  type StateBuilder () =
    member b.Bind(m, f) = bind m f

    member b.BindUsing(m, f) = bind m (fun r -> using r f)

    member b.Combine(m1, m2) = bind m1 (fun () -> m2)
 
    member b.Delay(f) = delay f

    member b.For(s:#seq<_>, f:('a->State<unit, 'b>)) =
      using (s.GetEnumerator()) (fun ie ->
        do_while (fun () -> ie.MoveNext()) (delay (fun() -> f ie.Current))
      )

//    member b.Let(x, f) = f x

    member b.Return(x) = succeed x

    member b.TryFinally (m, f) = try_finally m f

    member b.TryWith(m, f) = try_with m f

    member b.Using(x : #IDisposable, f) = try_finally (f x) (fun () -> x.Dispose())

    member b.While(p, m:State<unit, 'a>) = do_while p m

    member b.Zero() = succeed ()

  let state = StateBuilder()

  let GetState = State (fun s -> s, s)

  let SetState s = State (fun _ -> (), s) 

  let MapState f =
    State (fun s ->(), f s)

  let Eval m s =
    let _, s = Run m s
    s

  let Exec m s =
    let v, _ = Run m s
    v

  let MapStateAndResult f m =
    State (fun s ->
      let v, s = Run m s
      let v', s' = f v s
      Run (succeed v') s'
    )   

  